#!/usr/bin/perl

# DS Kanji Flash
# Copyright (C) 2009,2010 Bernhard Schelling
#
# This file is part of DS Kanji Flash.
#
# DS Kanji Flash is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# DS Kanji Flash is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with DS Kanji Flash.  If not, see <http://www.gnu.org/licenses/>.

use utf8;
use strict;
use Encode;

my $dirChars = "takadbxml/character/";
my $dirElems = "takadbxml/element/";

################Get paths of TTF kanji character
#sub outglyph
#{
#	use GD;
#	my $img = new GD::Image(512,512);
#	$img->colorAllocate(255,255,255);
#	my @x = @{$_[0]->{x}};
#	my @y = @{$_[0]->{y}};
#	my ($point, $c) = (-1, 0);
#	foreach my $endpoint (@{$_[0]->{endPoints}})
#	{
#		$img->line(256+$x[$point+1],256-$y[$point+1],256+$x[$endpoint],256-$y[$endpoint], $img->colorAllocate($c++,$c++,$c++));
#		while ((++$point) < $endpoint)
#			{ $img->line(256+$x[$point],256-$y[$point],256+$x[$point+1],256-$y[$point+1], $img->colorAllocate($c++,$c++,$c++)); }
#	}
#	open(OUTIMG, ">ttfglyph.png"); binmode(OUTIMG); print OUTIMG $img->png; close(OUTIMG);
#}
#use Font::TTF::Font; use Font::TTF::Ttc;
#my $ttc = Font::TTF::Ttc->open("C:\\Windows\\Fonts\\msmincho.ttc");
#my $f = $ttc->{directs}[0];
#my $glyphs = $f->{'loca'}->read->{'glyphs'};
#my $gid = $f->{'cmap'}->read->ms_lookup(0x306B);  #$f->{'cmap'}->read->{'Tables'}[1]{'val'}{0x306F};
#print "GID: $gid\n";
#my $g = @$glyphs[$gid];
#next unless $g;
#$g->read_dat;
#outglyph($g);
##use Font::TTF::Dumper; print ttfdump($g)."\n";
#$g->empty;


##########dump all element curves to a big image
#use GD;
#my $img = new GD::Image(3200,3200);
#$img->colorAllocate(255,255,255);
#$img->colorAllocate(0,0,0);
#$img->colorAllocate(200,200,200);
#my $knum = 0;
#opendir(DIRELEMS, $dirElems);
#for my $f (readdir(DIRELEMS))
#{
#	next unless (-f $dirElems.$f) and ($f =~ /^(\d+)\.xml$/i);
#	foreach my $strokes (GetStrokes($1))
#	{
#		next if @$strokes > 4;
#		my ($kx, $ky) = (($knum%100)*32, (int($knum/100)*32));
#		$img->rectangle($kx, $ky, $kx+32, $ky+32, 2);
#		for (@$strokes) { for (my $i=0;$i<@$_-2;$i+=2)
#			{ $img->line($kx+@$_[$i+0]*0.125,$ky+@$_[$i+1]*0.125,$kx+@$_[$i+2]*0.125,$ky+@$_[$i+3]*0.125, 1); } }
#		last if (++$knum) >= (100*100);
#	}
#	last if ($knum) >= (100*100);
#	print "$f done ($knum so far)\n";
#}
#closedir(DIRCHARS);
#open(OUTIMG, ">test.png"); binmode(OUTIMG); print OUTIMG $img->png; close(OUTIMG);
#exit;


#######bezier courve test
#sub bez
#{
#	my ($t, @x) = @_;
#	my $u = 1-$t;
#	return $x[0] * $u*$u*$u*$u + 4 * $x[1] * $t*$u*$u*$u + 6 * $x[2] * $t*$t*$u*$u + 4 * $x[3] * $t*$t*$t*$u + $x[3]*$t*$t*$t*$t;
#	return $x[0] * $u*$u*$u        + 3 * $x[1] * $t*$u*$u        + 3 * $x[2] * $t*$t*$u                                      + $x[2]*$t*$t*$t;
#}
#use GD;
#my $img = new GD::Image(1000,1000);
#$img->colorAllocate(255,255,255);
#$img->colorAllocate(200,200,200);
#$img->colorAllocate(0,0,0);
#my @x = (139, 131, 83, 20); #(100, 200, 850, 900);
#my @y = (28, 121, 195, 228); #(700, 500, 220, 800);
#for (my $i=0;$i<@x-1;$i++) { $img->line($x[$i], $y[$i], $x[$i+1], $y[$i+1], 1); }
#for (my $t=0;$t<0.999;$t+=(1/60)) { $img->line(bez($t, @x), bez($t, @y), bez($t+(1/60), @x), bez($t+(1/60), @y), 2); }
#open(OUTIMG, ">test.png"); binmode(OUTIMG); print OUTIMG $img->png; close(OUTIMG);
#exit;

use Archive::Zip;
use Archive::Zip::MemberRead;
my $zip = Archive::Zip->new("takadbxml.zip");
my (@characters, @elements);
for my $zf ($zip->membersMatching('^takadbxml/character/.*\.xml$'))
{ @characters[int((($zf->fileName() =~ /\/(\d+)\.xml/i))[0])] = scalar $zf->contents(); }
for my $zf ($zip->membersMatching('^takadbxml/element/.*\.xml$'))
{ @elements[int((($zf->fileName() =~ /\/(\d+)\.xml/i))[0])] = scalar $zf->contents(); }

#######Test output result
#foreach my $strokes (GetStrokes(1976)) #1557 = kawa, 1135 = hito , 1058 = suki
#{
#	for (my $i=0;$i<@$strokes;$i++) { @$strokes[$i] = join(",", @{@$strokes[$i]}); }
#	print "ENTRY: ".join("/", @$strokes)."\n";
#}
#exit;

open(OUT,">:encoding(utf-8)","takadb.txt");
print "Dumping stroke infos...\n";
#######Convert from directories instead of pre-parsing all data
##opendir(DIRCHARS, $dirChars);
##for my $f (readdir(DIRCHARS))
#for my $zf ($zip->membersMatching('^takadbxml/character/.*\.xml$'))
#{
#	my $f = $zf->fileName();
#	my ($fh, $ucscode, $elementid);
#	#next unless (-f $dirChars.$f) and ($f =~ /\.xml$/i);
#	##next unless $f eq "1147.xml";
#	#open($fh, $dirChars.$f);
#	#while (<$fh>)
#	my $fh = Archive::Zip::MemberRead->new($zf);
#	while (defined($_ = $fh->getline()))
#	{
#		$ucscode = $1 if /<jaUcsCode>(\d+)<\/jaUcsCode>/;
#		$elementid = $1 if /<jaElementId>(\d+)<\/jaElementId>/;
#		last if $ucscode and $elementid;
#	}
#	#close($fh);
#	my $zfe = $zip->memberNamed("takadbxml/element/".$elementid.".xml");
#	#next unless $ucscode and $elementid and -f $dirElems.$elementid.".xml";
#	next unless $ucscode and $elementid and $zfe;
#	print "Dumping stroke info for $ucscode (Char: $f - Element: $elementid)...\n";
#	foreach my $strokes (GetStrokes($elementid))
#	{
#		for (my $i=0;$i<@$strokes;$i++) { @$strokes[$i] = join(",", @{@$strokes[$i]}); }
#		print OUT chr($ucscode)." ".$elementid." ".join("/", @$strokes)."\n";
#	}
#	#my @strokes = GetStrokes($elementid, -1);
#	#for (my $i=0;$i<@strokes;$i++) { $strokes[$i] = join(",", @{$strokes[$i]}); }
#	#print OUT chr($ucscode)." ".$elementid." ".join("/", @strokes)."\n";
#}
#closedir(DIRCHARS);
for (my $i = 0; $i < @characters; $i++)
{
	$_ = $characters[$i];
	my $ucscode = $1 if /<jaUcsCode>(\d+)<\/jaUcsCode>/;
	my $elementid = $1 if /<jaElementId>(\d+)<\/jaElementId>/;
	next unless $ucscode and $elementid and $elements[$elementid];
	print "Dumping stroke info for $ucscode (Char: $i - Element: $elementid)...\n";
	foreach my $strokes (GetStrokes($elementid))
	{
		for (my $i=0;$i<@$strokes;$i++) { @$strokes[$i] = join(",", @{@$strokes[$i]}); }
		print OUT chr($ucscode)." ".$elementid." ".join("/", @$strokes)."\n";
	}
}
close(OUT);

sub GetStrokes
{
	my ($elementid, $wantvar) = @_;
	my ($lasttagsec, $segtype, $haswantvar, $minnum, @retent, %entries, %entry, @strokes, @segpoints, @pelements, %parts) = ("", "M", 0, 0);
	#open(ELEM, $dirElems.$elementid.".xml");
	#while (<ELEM>)
	#my $fh = Archive::Zip::MemberRead->new($zip, "takadbxml/element/".$elementid.".xml");
	#while (defined($_ = $fh->getline()))
	for (split(/\r?\n/, $elements[$elementid]))
	{
		#chomp();
		$lasttagsec = lc($1) if /<(\w+)>(\r|\n|$)/;
		push(@pelements, $1) if $lasttagsec eq "pelementid" and /<int>(\d+)<\/int>/i and $1;
		%entry = (num => 0, width => 100, height => 100) if /<entry>/i;
		$entry{num} = int($1)                             if $lasttagsec eq "entry" and /<int>(\d+)<\/int>/i;
		$minnum = ($minnum&&$minnum < $1 ? $minnum : $ 1) if $lasttagsec eq "entry" and /<int>(\d+)<\/int>/i;
		$entry{width} = int($1)  if /<width>(\d+)<\/width>/i;
		$entry{height} = int($1) if /<height>(\d+)<\/height>/i;
		push(@{$parts{glyphvariant}}, $1) if $lasttagsec eq "pglyphvariant" and /<int>(\d+)<\/int>/i;
		push(@{$parts{x}}, $1)            if $lasttagsec eq "px" and /<int>(\d+)<\/int>/i;
		push(@{$parts{y}}, $1)            if $lasttagsec eq "py" and /<int>(\d+)<\/int>/i;
		push(@{$parts{width}}, $1)        if $lasttagsec eq "pwidth" and /<int>(\d+)<\/int>/i;
		push(@{$parts{height}}, $1)       if $lasttagsec eq "pheight" and /<int>(\d+)<\/int>/i;
		@{$strokes[@strokes]} = () if /<stroke>/i;
		@segpoints = () if /<segment>/i;
		$segtype = $1 if /<type>([MLC])<\/type>/i;
		push(@{$strokes[-1]}, @segpoints[0,1]) if ((/<\/segment>/i) && (($segtype ne "C") || (@segpoints != 6) || (@{$strokes[-1]} < 2)));
		if ((/<\/segment>/i) && ($segtype eq "C") && (@segpoints == 6) && (@{$strokes[-1]} >= 2))
		{
			#bezier curve
			my @mpoint = @{$strokes[-1]}[-2,-1];
			if (30 < sqrt(($mpoint[0]-$segpoints[4])*($mpoint[0]-$segpoints[4])+($mpoint[1]-$segpoints[5])*($mpoint[1]-$segpoints[5])))
			{ for (my $t=(1/8);$t<=1;$t+=(1/8)) { for (0,1) { push(@{$strokes[-1]}, $mpoint[$_] * (1-$t)*(1-$t)*(1-$t)*(1-$t) + 4 * $segpoints[$_+0] * $t*(1-$t)*(1-$t)*(1-$t) + 6 * $segpoints[$_+2] * $t*$t*(1-$t)*(1-$t) + 4 * $segpoints[$_+4] * $t*$t*$t*(1-$t) + $segpoints[$_+4] * $t*$t*$t*$t); } } }
			## 3p for (my $t=0;$t<=1;$t+=(1/4)) { for (0,1) { push(@{$strokes[-1]} $segpoints[$_+0] * (1-$t)*(1-$t)*(1-$t)    + 3 * $segpoints[$_+2] * $t*(1-$t)*(1-$t)        + 3 * $segpoints[$_+4] * $t*$t*(1-$t)                                                 + $segpoints[$_+4]*$t*$t*$t); } }
			else { push(@{$strokes[-1]}, @segpoints); }
		}
		#push(@{$strokes[-1]}, ($segtype eq "C"?@segpoints:@segpoints[0,1])) if /<\/segment>/i;
		push(@segpoints, $1) if (($lasttagsec eq "points") and (/<float>([\d\.]+)<\/float>/i));
		$entries{$entry{num}} = {%entry, strokes => [@strokes], parts => {%parts}} if /<\/entry>/i;
		$haswantvar = 1                                                        if (/<\/entry>/i && $wantvar && $entry{num} == $wantvar);
		(%entry, %parts, @strokes) = (undef, undef, undef)                      if /<\/entry>/i;
	}
	close(ELEM);
	if ($wantvar && !$haswantvar) { $wantvar = $minnum; $haswantvar = 1; }
	for my $ek (sort keys %entries)
	{
		my $e = $entries{$ek};
		next if ($wantvar && $haswantvar && $e->{num} != $wantvar);
		my @strokes;
		if (@{$e->{strokes}})
		{
			for my $s (@{$e->{strokes}})
			{
				@{$strokes[@strokes]} = ();
				for (my $p=0;$p<@$s;$p++) { my ($v,$s) = (@$s[$p],($p%2?$e->{height}:$e->{width})); push(@{$strokes[-1]}, int($v*256/$s)); }
			}
			#print "Points: ".int(@{$strokes[-1]})." (".join(",",@{$strokes[-1]}).")\n";
			for (my $p = 4;$p < int(@{$strokes[-1]});$p+=2)
			{
				my $len = sqrt((@{$strokes[-1]}[$p-4]-@{$strokes[-1]}[$p-2])*(@{$strokes[-1]}[$p-4]-@{$strokes[-1]}[$p-2])+(@{$strokes[-1]}[$p-3]-@{$strokes[-1]}[$p-1])*(@{$strokes[-1]}[$p-3]-@{$strokes[-1]}[$p-1]))+sqrt((@{$strokes[-1]}[$p-2]-@{$strokes[-1]}[$p+0])*(@{$strokes[-1]}[$p-2]-@{$strokes[-1]}[$p+0])+(@{$strokes[-1]}[$p-1]-@{$strokes[-1]}[$p+1])*(@{$strokes[-1]}[$p-1]-@{$strokes[-1]}[$p+1]));
				if ($len < 10) { splice(@{$strokes[-1]}, $p-2, 2); $p -=2; }
			}
		}
		else
		{
			my %parts = %{$e->{parts}};
			for (my $i=0;$i<@pelements;$i++)
			{
				#print "Element $elementid Ent #".$e->{num}." Part #$i GET ".$pelements[$i]." var #".int($parts{glyphvariant}->[$i])."\n";
				my @pstrokes = GetStrokes($pelements[$i], int($parts{glyphvariant}->[$i]));
				for (my $s=0;$s<@pstrokes;$s++)
				{
					#print "   STROKE: ".join(",", @{$pstrokes[$s]})."\n";
					@{$strokes[@strokes]} = ();
					my ($px, $py, $pw, $ph) = (int($parts{x}->[$i]), int($parts{y}->[$i]), ($parts{width}->[$i]?$parts{width}->[$i]:100), ($parts{height}->[$i]?$parts{height}->[$i]:100));
					for (my $p=0;$p<@{$pstrokes[$s]};$p++) { my ($v,$po,$ps, $s) = ($pstrokes[$s]->[$p],$p%2?($py,$ph,$e->{height}):($px,$pw,$e->{width})); push(@{$strokes[-1]}, int(($po*256/$s)+($v*$ps/$s))); }
				}
			}
		}
		#print "$elementid - Returning variant ".$e->{num}."\n";
		return @strokes if $wantvar;
		push(@retent, [@strokes]);
	}
	return @retent;
}
